home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH6 / SRC / LEASTSQ.FRM < prev    next >
Text File  |  1996-03-28  |  4KB  |  150 lines
  1. VERSION 4.00
  2. Begin VB.Form LeastSquareForm 
  3.    Caption         =   "Least Squares"
  4.    ClientHeight    =   5310
  5.    ClientLeft      =   2085
  6.    ClientTop       =   900
  7.    ClientWidth     =   4830
  8.    Height          =   6000
  9.    Left            =   2025
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   354
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   322
  14.    Top             =   270
  15.    Width           =   4950
  16.    Begin VB.CommandButton CmdGo 
  17.       Caption         =   "Go"
  18.       Default         =   -1  'True
  19.       Enabled         =   0   'False
  20.       Height          =   375
  21.       Left            =   2040
  22.       TabIndex        =   1
  23.       Top             =   4920
  24.       Width           =   615
  25.    End
  26.    Begin VB.PictureBox Canvas 
  27.       AutoRedraw      =   -1  'True
  28.       Height          =   4815
  29.       Left            =   0
  30.       ScaleHeight     =   317
  31.       ScaleMode       =   3  'Pixel
  32.       ScaleWidth      =   317
  33.       TabIndex        =   0
  34.       Top             =   0
  35.       Width           =   4815
  36.    End
  37.    Begin VB.Menu mnuFile 
  38.       Caption         =   "&File"
  39.       Begin VB.Menu mnuFileExit 
  40.          Caption         =   "E&xit"
  41.       End
  42.    End
  43. End
  44. Attribute VB_Name = "LeastSquareForm"
  45. Attribute VB_Creatable = False
  46. Attribute VB_Exposed = False
  47. Option Explicit
  48.  
  49. Dim NumPts As Integer
  50. Dim PtX() As Single
  51. Dim PtY() As Single
  52.  
  53.  
  54.  
  55. ' ************************************************
  56. ' Compute the m and b values for the least squares
  57. ' line.
  58. ' ************************************************
  59. Sub GetLeastSquaresValues(num As Integer, X() As Single, Y() As Single, mvalue As Single, bvalue As Single)
  60. Dim A As Single
  61. Dim B As Single
  62. Dim C As Single
  63. Dim D As Single
  64. Dim i As Integer
  65.  
  66.     ' Compute the sums.
  67.     For i = 1 To NumPts
  68.         A = A + PtX(i) * PtX(i)
  69.         B = B + PtX(i)
  70.         C = C + PtX(i) * PtY(i)
  71.         D = D + PtY(i)
  72.     Next i
  73.     mvalue = (B * D - C * NumPts) / (B * B - A * NumPts)
  74.     bvalue = (B * C - A * D) / (B * B - A * NumPts)
  75. End Sub
  76.  
  77.  
  78.  
  79.  
  80.  
  81. ' ************************************************
  82. ' Add this point to the list of points.
  83. ' ************************************************
  84. Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  85. Const GAP = 2
  86.  
  87.     ' If this is the first point, erase the screen.
  88.     If NumPts < 1 Then Canvas.Cls
  89.     
  90.     ' Record the new point.
  91.     NumPts = NumPts + 1
  92.     ReDim Preserve PtX(1 To NumPts)
  93.     ReDim Preserve PtY(1 To NumPts)
  94.     PtX(NumPts) = X
  95.     PtY(NumPts) = Y
  96.  
  97.     ' Display the point.
  98.     Canvas.Line (X - GAP, Y - GAP)-(X + GAP, Y + GAP), , BF
  99.  
  100.     ' If NumPts >= 2, enable the Go button.
  101.     If NumPts >= 2 Then CmdGo.Enabled = True
  102. End Sub
  103.  
  104.  
  105. ' ************************************************
  106. ' Draw the least squares fit curve.
  107. ' ************************************************
  108. Private Sub CmdGo_Click()
  109.     CmdGo.Enabled = False
  110.  
  111.     DrawCurve
  112.     
  113.     ' Prepare to get a new set of points.
  114.     NumPts = 0
  115. End Sub
  116. ' ************************************************
  117. ' Draw the least squares line.
  118. ' ************************************************
  119. Sub DrawCurve()
  120. Dim mvalue As Single
  121. Dim bvalue As Single
  122. Dim x1 As Single
  123. Dim x2 As Single
  124. Dim y1 As Single
  125. Dim y2 As Single
  126. Dim i As Integer
  127.  
  128.     ' Get the m and b values for the line.
  129.     GetLeastSquaresValues NumPts, PtX, PtY, mvalue, bvalue
  130.     
  131.     ' Find the minimum and maximum X values.
  132.     x1 = PtX(1) ' This will be the minimum X value.
  133.     x2 = x1     ' This will be the maximum X value.
  134.     For i = 2 To NumPts
  135.         If x1 > PtX(i) Then x1 = PtX(i)
  136.         If x2 < PtX(i) Then x2 = PtX(i)
  137.     Next i
  138.     
  139.     ' Draw the line.
  140.     y1 = mvalue * x1 + bvalue
  141.     y2 = mvalue * x2 + bvalue
  142.     Canvas.Line (x1, y1)-(x2, y2)
  143. End Sub
  144.  
  145. Private Sub mnuFileExit_Click()
  146.     Unload Me
  147. End Sub
  148.  
  149.  
  150.